\ ZEN version 1.70-- a simple classical Forth MJT 2/11/89 ZEN 1.70 is a model implementation of the unofficial ANS Forth with Double-Number, File Access, and BLOCK Standard Extensions (BASIS7). This model is not endorsed by the ANS X3J14 committee. { Comments to go back to the ANS committee look like this.} ZEN 1.70 generates an IBM PC 64K small-model ROM-able nucleus. BX register is top-of-stack. DTC with JMP code field. Assumes segment registers CS = DS = ES Thanks to Wil Baden for his suggestions. This is a working document. No guarantees are made to its accuracy or fitness. While this is a working document, it is copyrighted 1989 by Martin J. Tracy. All rights are reserved.\ ZEN nucleus FORTH DEFINITIONS 8 K-OF-ROM ! " KERNEL.COM" MAKE-OBJECT 32 CONSTANT #Jot ( number conversion area in bytes) 128 CONSTANT #Safe ( CREATE safety area-- in bytes) 128 CONSTANT #User ( total user area size-- in bytes) HEX 0100 BFFF 2DUP 2CONSTANT #ROM ROMORG 2! ( start & end of ROM) C000 FFFF 2DUP 2CONSTANT #RAM RAMORG 2! ( start & end of RAM) 0000 #User - CONSTANT #RP0 ( top of return stack) #RP0 0080 - CONSTANT #SP0 ( top of data stack) START DECIMAL 2 LOAD FINIS \ Main LOAD screen HERE EQU Power 2 CELLS ( power-up) GAP ," C 1989 by M Tracy" HERE EQU D0 #ROM , , #RAM , , HERE EQU H0 ( h) 0 , HERE EQU F0 0 , 0 , ( forth vlink) HERE EQU T0 ( r) 0 , HERE EQU S0 #SP0 , 8 18 THRU ( Kernal primitives) 20 28 THRU ( Numbers and I/O) 30 42 THRU ( Interpreter) 44 68 THRU ( Compiler) 70 74 THRU ( Device dependencies) 80 85 THRU ( Mass storage extension) 76 78 THRU ( Initialization) ( Application, if any) HERE H0 ! THERE T0 ! \ Documentation requirements ZEN 1.70 supports the Double-Number, File Access, and BLOCK Standard Extensions. To compile the BLOCK extension, load the file BLOCK.SRC. Division is rounded-down. To change to floored division, load the file DIVIDE.SRC. There are two 8-bit bytes per cell. Counted strings may be as long as 255 bytes. The system dictionary is approximately 7K address units (au's) leaving 56K for the application. { #RAM and #ROM are currently set for 40K of application dictionary and 16K of RAM.} The data stack grows towards the bottom of RAM, and may be as large as the application dictionary. The return stack is currently set for 64 cells of RAM. Only dumb (glass) terminals are supported. \ General exception conditions If the input stream is inadvertantly exhausted: ABORT" ?" If insufficient number of stack entries: ABORT" Stack?" If a word is not found or not a number: ABORT" ?" Execution of compiler words while interpreting is not prevented;the result of such execution is undefined. If insufficient space in the dictionary: ABORT" No Room" Inappropriate and out-of-range arguments are not checked: the result of using such arguments is very undefined. Overflow of pictured numeric output string is not detected. Division by zero returns a quotient of zero and a remainder equal to the dividend. Quotient out of range is not detected. {If FORGETing within the nucleus: ABORT" Can't"} {What is p.23 "parsed string overflow"?} \ Exception conditions ' ['] FIND see word not found or not a number. */ / /MOD M*/ M/ M/MOD MOD see division by zero. READ-FILE WRITE-FILE set IO-RESULT to file error code. The following error conditions give unpredictable results: EXECUTE PERFORM do not detect invalid execution tokens. ABS CONVERT D>F D>S F>D do not detect argument out of range. BLOCK BUFFER LOAD do not detect block number out of range.PICK does not detect argument out of range. UPDATE does not detect no current block buffer.DO does not detect return stack overflow. {FORGET and PERFORM are CONTROLLED} \ Key to auxiliary commands Several words used by the metacompiler are described here. | make the next word headerless. ," ccc" compile the characters "ccc." a ORG reset HERE to address a. n EQU <name> equivalent to a headerless constant with value n.LABEL <name> equivalent to HERE EQU <name> but also activates the CODE assembler. CODE <name> begin a machine-code definition, usually ended by END-CODE or C; -------------------------------------------------------------- | || Please direct all comments and inquiries to: || || Martin Tracy, Secretary, ANS X314 Forth Committee || FORTH, Inc. || 111 North Sepulveda Blvd. || Manhattan Beach, California 90266 || || || || || || || | -------------------------------------------------------------- \ ------ Kernel primitives ------------------------ LABEL colon BP DEC BP DEC SI 0 [BP] MOV SI POP NEXT \ save I register on return stack and set it to new position. \ This is the action of the code field in all colon definitions. CODE EXIT NOP | CODE semi 0 [BP] SI MOV BP INC BP INC | CODE nope NEXT C; \ semi is the action of the semicolon in all colon definitions. \ EXIT differs from semi as an aid to decompilation. \ nope is a "no operation" word used for initialization. \ Data objects LABEL addr \ the action of all CREATEs. BX PUSH 3 # AX ADD BX AX XCHG NEXT LABEL con \ the action of all CONSTANTs and VARIABLEs. BX PUSH 3 # AX ADD BX AX XCHG 0 [BX] BX MOV NEXT C; VARIABLE u { Private} \ USER area pointer. LABEL uvar \ the action of all USER variables. BX PUSH 3 # AX ADD BX AX XCHG 0 [BX] BX MOV u ) BX ADD NEXT LABEL (does) BP DEC BP DEC SI 0 [BP] MOV \ run-time DOES> SI POP BX PUSH 3 # AX ADD BX AX XCHG NEXT C; \ Stack manipulation CODE DUP ( w - w w) BX PUSH NEXT C; CODE DROP ( w) BX POP NEXT C; CODE SWAP ( w w2 - w2 w) SP DI MOV BX 0 [DI] XCHG NEXT C; CODE OVER ( w w2 - w w2 w) SP DI MOV BX PUSH 0 [DI] BX MOV NEXT C; CODE ROT ( w w2 w3 - w2 w3 w) DX POP AX POP DX PUSH BX PUSH AX BX MOV NEXT C; CODE PICK ( w[u]...w[1] w[0] u - w[u]...w[1] w[0] w[u]) \ copy kth item to top of stack. BX SHL SP BX ADD 0 [BX] BX MOV NEXT C; { CONTROLLED} \ Memory access CODE @ ( a - w) 0 [BX] BX MOV NEXT C; CODE ! ( w a) 0 [BX] POP BX POP NEXT C; CODE C@ ( a - b) 0 [BX] BL MOV BH BH SUB NEXT C; CODE C! ( b a) AX POP AL 0 [BX] MOV BX POP NEXT C; CODE CMOVE ( a a2 u) \ move count bytes from from to to, leftmost byte first. BX CX MOV SI BX MOV DI POP SI POP REP BYTE MOVS BX SI MOV BX POP NEXT C; \ Math operators | CODE tic NOP | CODE lit WORD LODS BX PUSH AX BX MOV NEXT C; \ push the following (in-line) number onto the stack. CODE + ( n n2 - n3) AX POP AX BX ADD NEXT C; CODE - ( n n2 - n3) AX POP AX BX SUB BX NEG NEXT C; CODE NEGATE ( n - n2) BX NEG NEXT C; CODE ABS ( n - +n2) BX BX OR 1 L# JNS BX NEG 1 L: NEXT C; CODE +! ( n a) AX POP AX 0 [BX] ADD BX POP NEXT C; \ increment number at address by n. \ Math and logical CODE 1+ ( n - n2) BX INC NEXT C; CODE 1- ( n - n2) BX DEC NEXT C; CODE 2* ( n - n2) BX SHL NEXT C; CODE 2/ ( n - n2) BX SAR NEXT C; ( arithmetic) CODE AND ( m m2 - m3) AX POP AX BX AND NEXT C; CODE OR ( m m2 - m3) AX POP AX BX OR NEXT C; CODE XOR ( m m2 - m3) AX POP AX BX XOR NEXT C; CODE NOT ( w - w2) BX NOT NEXT C; { ( m - m2) ?} \ Comparisons CODE 0 ( - n) BX PUSH BX BX SUB NEXT C; { Feature} CODE 1 ( - n) BX PUSH 1 # BX MOV NEXT C; { Feature} CODE TRUE ( - m) BX PUSH -1 # BX MOV NEXT C; { Control?} CODE = ( n n2 - f) AX POP AX BX CMP TRUE # BX MOV 1 L# JZ BX INC 1 L: NEXT C; CODE < ( n n2 - f) AX POP BX AX SUB TRUE # BX MOV 1 L# JL BX INC 1 L: NEXT C; CODE U< ( u u2 - f) AX POP BX AX SUB TRUE # BX MOV 1 L# JB BX INC 1 L: NEXT C; : > ( n n2 - f) SWAP < ; \ Comparisons against zero and CELL operators CODE 0= ( n - f) BX BX OR TRUE # BX MOV 1 L# JZ BX INC 1 L: NEXT C; CODE 0< ( n - f) BX BX OR TRUE # BX MOV 1 L# JS BX INC 1 L: NEXT C; : 0> ( n - f) 0 > ; 2 CONSTANT CELL { Feature} CODE CELL+ ( a - a2) BX INC BX INC NEXT C; CODE CELLS ( a - a2) BX SHL NEXT C; \ Branches and loops | CODE branch \ unconditional branch. 0 [SI] SI MOV NEXT C; | CODE ?branch ( f) \ branch if zero. BX BX OR BX POP ' branch JZ 2 # SI ADD NEXT C; | CODE (do) ( n n2) \ begin DO...LOOP structure. 4 # BP SUB AX POP HEX 8000 DECIMAL # AX ADD AX 2 [BP] MOV AX BX SUB BX 0 [BP] MOV BX POP NEXT C; | CODE (loop) \ terminate DO...LOOP structure. WORD 0 [BP] INC ' branch JNO LABEL >loop 2 # SI ADD | CODE >undo 4 # BP ADD NEXT | CODE (+loop) ( n) \ terminate DO...+LOOP structure. BX 0 [BP] ADD BX POP ' branch JNO >loop JO NEXT C; \ Return stack CODE >R ( w) BP DEC BP DEC BX 0 [BP] MOV BX POP NEXT C; CODE R@ ( - w) BX PUSH 0 [BP] BX MOV NEXT C; CODE I ( - n) BX PUSH 0 [BP] BX MOV 2 [BP] BX ADD NEXT C; CODE J ( - n) BX PUSH 4 [BP] BX MOV 6 [BP] BX ADD NEXT C; CODE R> ( - w) BX PUSH 0 [BP] BX MOV BP INC BP INC NEXT C; CODE 2>R ( w w2) \ push w and w2 to the return stack, w2 on top. 4 # BP SUB BX 0 [BP] MOV 2 [BP] POP BX POP NEXT C; CODE 2R> ( - w w2) \ pop w and w2 from the return stack. BX PUSH 2 [BP] PUSH 0 [BP] BX MOV 4 # BP ADD NEXT C; \ Optimizations and EXECUTE CODE NIP ( w w2 - w2) { CONTROLLED} AX POP NEXT C; CODE TUCK ( w w2 - w2 w w2) { CONTROLLED} AX POP BX PUSH AX PUSH NEXT C; CODE ?DUP ( w - w w | 0 - 0) BX BX OR 1 L# JZ BX PUSH 1 L: NEXT C; CODE EXECUTE ( w) BX AX XCHG BX POP AX JMP C; CODE PERFORM ( w) { CONTROLLED} \ PERFORM is equivalent to @ EXECUTE but is much faster. BX DI MOV BX POP 0 [DI] AX MOV AX JMP C; \ ------ Input/Output ----------------------------- \ In ZEN, consecutive headerless variables form a category \ which can be extended but not reduced or reordered. 0 USER entry 2 CELLS + ( skip multitasking hooks) USER r | USER SP0 USER x \ XFER vector pointer. USER BASE | USER dpl | USER hld EQU #I/0 : THERE ( - a) r @ ; { ROM} : PAD ( - a) r @ [ #Jot ] LITERAL + ; { CONTROLLED} : DECIMAL 10 BASE ! ; : HEX 16 BASE ! ; { CONTROLLED} \ Double-value data stack operators CODE 2DUP ( w w2 - w w2 w w2) SP DI MOV BX PUSH 0 [DI] PUSH NEXT C; CODE 2DROP ( w w2) BX POP BX POP NEXT C; CODE 2SWAP ( w w2 w3 w4 - w3 w4 w w2) AX POP CX POP DX POP AX PUSH BX PUSH DX PUSH CX BX MOV NEXT C; : 2OVER ( d d2 - d d2 d) 2>R 2DUP 2R> 2SWAP ; : 2ROT ( d d2 d3 - d2 d3 d) 2R> 2SWAP 2R> 2SWAP ; { CONTROLLED} CODE 2@ ( a - w w2) 2 [BX] PUSH 0 [BX] BX MOV NEXT C; CODE 2! ( w w2 a) 0 [BX] POP 2 [BX] POP BX POP NEXT C; \ Numeric conversion math support CODE D+ ( d d2 - d3) AX POP DX POP CX POP AX CX ADD CX PUSH DX BX ADC NEXT C; CODE DNEGATE ( d - d2) AX POP AX NEG AX PUSH 0 # BX ADC BX NEG NEXT C; : MAX ( n n2 - n3) 2DUP < IF SWAP THEN DROP ; : MIN ( n n2 - n3) 2DUP < 0= IF SWAP THEN DROP ; \ Numeric conversion math support CODE UM* ( u u2 - ud) AX POP BX MUL AX PUSH DX BX MOV NEXT C; CODE UM/MOD ( ud u - u2 u3) \ return rem u2 and quot u3 of unsigned ud divided by u. \ On zero-divide, return quot=0 and rem=low-word-of-ud. DX POP AX AX SUB BX DX CMP 1 L# JAE AX POP BX DIV DX PUSH 1 L: AX BX MOV NEXT C; \ Input number conversion ASCII A ASCII 9 1+ - EQU A-10 | : digit ( c base - n t | ? 0) \ true if the char c is a valid digit in the given base. SWAP [ASCII] 0 - 9 OVER < DUP IF DROP A-10 - 10 THEN >R DUP R@ - ROT R> - U< ; : CONVERT ( +d a - +d2 a2) \ convert the char sequence at a+1 and accumulate it in +d. \ a2 is the address of the first non-convertable digit. BEGIN 1+ DUP >R C@ BASE @ digit WHILE SWAP BASE @ UM* DROP ROT BASE @ UM* D+ R> REPEAT DROP R> ; \ Output number conversion : <# PAD hld ! ; : #> ( wd - a u) 2DROP hld @ PAD OVER - ; : HOLD ( c) TRUE hld +! hld @ C! ; \ add character c to output string. : SIGN ( n) 0< IF [ASCII] - HOLD THEN ; \ add "-" to output string if w is negative. : # ( ud - ud2) \ transfer the next digit of ud to the output string. BASE @ >R 0 R@ UM/MOD R> SWAP >R UM/MOD R> ROT 9 OVER < IF A-10 + THEN [ASCII] 0 + HOLD ; : #S ( ud - ud2) BEGIN # 2DUP OR 0= UNTIL ; \ convert all remaining digits of ud. ud2 is 0 0 . \ Transfers LABEL xvar \ the action of all transfers. u ) DI MOV x [DI] DI MOV 3 # AX ADD DI AX XCHG 0 [DI] DI MOV AX DI ADD 0 [DI] AX MOV AX JMP C; 0 XFER TYPE ( a u) XFER CR XFER KEYS ( a u) { Private} XFER KEY? ( - f) { Extend?} XFER MARK ( a u) { Extend?} XFER PAGE { Extend?} XFER TAB ( n n2) { Extend?} ( Reserved) DROP \ KEYS is a simple unfiltered EXPECT which doesn't echo. \ KEY? is true if a key is available. \ MARK is like TYPE but highlights if possible. \ PAGE clears the screen. \ TAB moves the cursor to the x (n) and y (n2) coordinates. \ Print spaces 32 CONSTANT BL { CONTROLLED} \ ASCII blank HERE ( *) BL , : SPACE ( *) LITERAL 1 TYPE ; HERE ( * ) BL C, BL C, BL C, BL C, BL C, BL C, BL C, BL C, : SPACES ( +n ) \ output w spaces. Optimized for TYPE. ( * ) LITERAL OVER 2/ 2/ 2/ ?DUP IF 0 DO DUP 8 TYPE LOOP THEN SWAP 7 AND TYPE ; \ Print numbers | : (d.) ( d - a u) \ convert a double number to a string. TUCK DUP 0< IF DNEGATE THEN <# #S ROT SIGN #> ; : D. ( d) (d.) TYPE SPACE ; : U. ( u) 0 D. ; : . ( n) DUP 0< D. ; \ ------ Interpreter ------------------------------ #I/O ( continued from I/O layer) USER BLK { BLOCK} { Require?} USER >IN \ keep together. USER #TIB CELL+ \ #TIB and TIB's value. USER SPAN USER STATE EQU #Used VARIABLE last CELL ALLOT \ last lfa and cfa. | VARIABLE scr CELL ALLOT \ last error location. | VARIABLE bal | VARIABLE leaf \ see compiler. VARIABLE CONTEXT { CONTROLLED} VARIABLE CURRENT { CONTROLLED} : TIB ( - a) #TIB CELL+ @ ; \ Automatic variables \ These variables are automatically initialized; see COLD. VARIABLE h | VARIABLE f CELL ( ie vlink) ALLOT VARIABLE 'pause \ multitasking hook. | VARIABLE 'expect \ deferred EXPECT | VARIABLE 'source \ deferred input stream. | VARIABLE 'warn \ redefinition warning. | VARIABLE 'loc \ source location field. | VARIABLE 'val CELL ALLOT \ string to number conversion. \ number compilation. | VARIABLE key' CELL ALLOT \ one-key look-ahead buffer. : HERE ( - a) h @ ; ( String operators-- high-level definitions ) EXIT : COUNT ( a - a2 u) DUP C@ SWAP 1+ ; \ transform counted string into text string. : /STRING ( a u n - a2 u2) { Control?} ROT OVER + ROT ROT - ; \ truncate leftmost n chars of string. n may be negative. : SKIP ( a u b - a2 u2) { Control?} \ return shorter string from first position unequal to byte. >R BEGIN DUP WHILE OVER C@ R@ - IF R> DROP EXIT THEN 1 /STRING REPEAT R> DROP ; : SCAN ( a u b - a2 u2) { Control?} \ return shorter string from first position equal to byte. >R BEGIN DUP WHILE OVER C@ R@ = IF R> DROP EXIT THEN 1 /STRING REPEAT R> DROP ; ( String operators-- low-level definitions ) CODE COUNT ( a - a2 u) BX AX MOV AX INC \ transform counted string into text string. 0 [BX] BL MOV BH BH SUB AX PUSH NEXT C; CODE /STRING ( a u n - a2 u2) { Control?} CX POP AX POP \ truncate leftmost n chars of string. n may be negative. BX AX ADD BX CX SUB CX BX MOV AX PUSH NEXT C; CODE SKIP ( a u b - a2 u2) { Contr?} BX AX MOV CX POP DI POP \ return shorter string from first position unequal to byte. 1 L# JCXZ REPE BYTE SCAS 1 L# JZ CX INC DI DEC 1 L: DI PUSH CX BX MOV NEXT C; CODE SCAN ( a l b - a2 u2) { Contr?} BX AX MOV CX POP DI POP \ return shorter string from first position equal to byte. 1 L# JCXZ REPNE BYTE SCAS 1 L# JNZ CX INC DI DEC 1 L: DI PUSH CX BX MOV NEXT C; \ More string operators CODE FILL ( a u b) \ store u b's, starting at addr a. BX AX MOV CX POP DI POP REP BYTE STOS BX POP NEXT C; : -TRAILING ( a +n - a2 +n2) 2DUP \ alter string to suppress trailing blanks. BEGIN 2DUP BL SKIP DUP WHILE 2SWAP 2DROP BL SCAN REPEAT 2DROP NIP - ; EXIT : FILL ( a u b) \ store u b's, starting at addr a. SWAP ?DUP 0= IF 2DROP EXIT THEN >R OVER C! DUP 1+ R> 1- CMOVE ; \ Input stream operators | : source ( - a u) #TIB 2@ ; \ input stream source. : /source ( - a u) 'source PERFORM >IN @ /STRING ; | : accept ( n f) IF 1+ THEN >IN +! ; \ accept characters by incrementing >IN. : parse ( c - a u) \ parse a character-delimited string. >R /source OVER SWAP R> SCAN >R OVER - DUP R> accept ; : WORD ( c - a) \ parse a character-delimited string; \ leading delimiters are accepted and skipped; \ the string is counted and followed by a blank (not counted). >R /source OVER R> 2>R R@ SKIP OVER SWAP R> SCAN OVER R> - SWAP accept OVER - 31 MIN THERE DUP >R 2DUP C! 1+ SWAP CMOVE BL R@ COUNT + C! R> ; \ Dictionary search CODE thread ( a w - a 0 , cfa -1 , cfa 1) \ search vocabulary for a match with the packed name at a . DX POP SI PUSH 1 L: 0 [BX] BX MOV ( chain thru dictionary ) BX BX OR 5 L# JZ ( jump if end of thread ) DX DI MOV ( 'string) BX SI MOV 2 # SI ADD ( SI=nfa) 0 [SI] CL MOV 31 # CX AND 0 [DI] CL CMP ( count = ?) 1 L# JNZ ( lengths <>) DI INC SI INC ( to body of 'string) REPE BYTE CMPS ( names =?) 1 L# JNZ ( jump not matched) CX POP SI PUSH ( cfa ) CX SI MOV BYTE 32 # 2 [BX] TEST ( immediate bit ) TRUE # BX MOV 4 L# JZ BX NEG 4 L: NEXT 5 L: SI POP DX PUSH ( 'str) ( BX = 0) NEXT C; \ FIND [ and ] : FIND ( a - a 0 | a - w -1 | a - w 1) \ search dictionary for a match with the packed name at a . \ Return execution address and -1 or 1 ( IMMEDIATE) if found; \ ['] EXIT 1 if a has zero length; a 0 if not found. DUP C@ ( a l) DUP IF 31 MIN OVER C! ( a) CONTEXT @ thread ( a -1/0/1) DUP IF EXIT THEN CONTEXT @ f - IF DROP f thread THEN EXIT THEN ( a 0) 2DROP ['] EXIT 1 ; : ] TRUE STATE ! ; \ stop interpreting; start compiling. : [ 0 STATE ! ; \ stop compiling; start interpreting. IMMEDIATE \ Data and return stack \ Set data and return stack pointers, respectively: | CODE sp! ( a) BX SP MOV BX POP NEXT C; | CODE rp! ( a) BX BP MOV BX POP NEXT C; : RESET { Feature} \ reset return stack for error recovery. R> entry CELL - rp! >R ; : PRESET { Feature} \ empty both stacks and prepare system. SP0 @ sp! R> entry rp! >R SP0 @ 0 #TIB 2! 0 STATE ! ; | : err RESET ; CODE DEPTH ( - n) \ # items on stack before DEPTH is executed. BX PUSH u ) BX MOV SP0 [BX] BX MOV SP BX SUB BX SAR NEXT C; ( Memory management-- high-level definitions) EXIT : ALLOT ( n) r +! ; \ allocate n RAM data bytes. : GAP ( n) h +! ; \ allocate n dictionary bytes. { ROM} : C, ( w) h @ C! 1 h +! ; \ ie HERE C! 1 GAP ; \ append low byte of w onto the dictionary. : , ( w) h @ ! CELL h +! ; \ ie HERE ! CELL GAP ; \ append w onto the dictionary. EXIT { In an all-RAM system:} : GAP ALLOT ; : THERE HERE ; : >DATA >BODY ; ( Memory management-- low-level definitions) CODE ALLOT ( n) \ allocate n RAM data bytes. r # DI MOV u ) DI ADD BX 0 [DI] ADD BX POP NEXT C; CODE GAP ( n) \ allocate n dictionary bytes. { ROM} h # DI MOV BX 0 [DI] ADD BX POP NEXT C; CODE C, ( w) h # DI MOV 0 [DI] DI MOV \ append low byte of w onto the dictionary. BL 0 [DI] MOV 1 # BX MOV ' GAP JU CODE , ( w) h # DI MOV 0 [DI] DI MOV \ append w onto the dictionary. BX 0 [DI] MOV 2 # BX MOV ' GAP JU FORTH \ Code and data fields : >BODY ( w - a) 3 + ; : >DATA ( w - a) 3 + @ ; { ROM} : >code ( cfa - 'code) 1+ DUP @ CELL+ + ; \ finds code address associated with cfa. | : alter ( 'code cfa) 1+ TUCK CELL+ - SWAP ! ; \ point the cf to the given code addr. Skip the CALL byte. | : nest, ( 'code ) HERE 232 ( CALL) C, CELL GAP alter ; \ create the code field for colon words, DOES> and GOES> | : code, ( 'code ) HERE 233 ( JMP ) C, CELL GAP alter ; \ create the code field for data words. : patch ( 'code cfa) 233 ( JMP ) OVER C! alter ; \ make 'code the new action of the cf. Used by (;code). \ Alignment, string and error primitives \ : ALIGN HERE 1 AND GAP ; { ALIGN} \ force dictionary to the next even address. \ : REALIGN ( a - a2) DUP 1 AND + ; { ALIGN} \ force address to the next even address. | : (") ( - a l) R> COUNT 2DUP + ( REALIGN) >R ; \ leave the address and length of an in-line string. | : huh? ( w) 0= ABORT" ?" ; \ error action of several words. : ' ( - w) BL WORD DUP C@ huh? FIND huh? ; \ ------ Compiler --------------------------------- : COMPILE R> DUP CELL+ >R @ , ; \ compile the word that follows in the definition. : header \ create link and name fields. ( ALIGN) 'loc PERFORM ( extra fields ) BL WORD DUP C@ huh? 'warn PERFORM ( redefinition?) HERE last ! HERE CURRENT @ DUP @ , ! ( link field) HERE OVER C@ 1+ CMOVE ( name field) HERE C@ DUP 128 OR C, GAP HERE last CELL+ ! ; \ Defining words and DOES> : CREATE ( - a) header [ addr ] LITERAL code, ; : VARIABLE ( - a) header [ con ] LITERAL code, THERE , 0 THERE ! ( courtesy ) CELL ALLOT ; : CONSTANT ( - w) header [ con ] LITERAL code, , ; | : (;code) R> last CELL+ @ patch ; \ the code field of (;code) is at ' DOES> >BODY CELL+ : DOES> COMPILE (;code) [ (does) ] LITERAL nest, ; IMMEDIATE \ eg : KONST CREATE , DOES> @ ; \ Literals : LITERAL ( - w) COMPILE lit , ; IMMEDIATE \ compile w as a literal. : ['] ( - w) ' COMPILE tic , ; IMMEDIATE \ compile-form of ' ("tick"). : ASCII ( - c) BL WORD 1+ C@ ; \ return value of next char.: [ASCII] ( - c) \ compile value of next char. ASCII [COMPILE] LITERAL ; IMMEDIATE : STRING ( c) { Feature} \ string compiler, eg 32 STRING ABC parse DUP C, HERE OVER GAP SWAP CMOVE ( ALIGN) ; : " ( - a u) \ string literal, eg " cccc" COMPILE (") [ASCII] " STRING ; IMMEDIATE : ." [COMPILE] " COMPILE TYPE ; IMMEDIATE \ Flow of control | : ?bal DUP bal @ < huh? PICK @ 0= huh? ; | : -bal bal @ huh? TRUE bal +! DUP @ huh? ; : BEGIN HERE 1 bal +! ; IMMEDIATE : IF COMPILE ?branch [COMPILE] BEGIN 0 , ; IMMEDIATE : THEN 0 ?bal TRUE bal +! HERE SWAP ! ; IMMEDIATE : ELSE 0 ?bal COMPILE branch [COMPILE] BEGIN 0 , SWAP [COMPILE] THEN ; IMMEDIATE : UNTIL -bal COMPILE ?branch , ; IMMEDIATE : AGAIN -bal COMPILE branch , ; { CONTROLLED} IMMEDIATE : WHILE bal @ huh? [COMPILE] IF SWAP ; IMMEDIATE : REPEAT 1 ?bal [COMPILE] AGAIN [COMPILE] THEN ; IMMEDIATE \ Definite loops : DO COMPILE (do) [COMPILE] BEGIN ; IMMEDIATE : LEAVE COMPILE >undo COMPILE branch HERE leaf @ , leaf ! ; IMMEDIATE | : rake, \ gathers leaf's. Courtesy of Wil Baden. DUP , leaf @ BEGIN 2DUP U< WHILE DUP @ HERE ROT ! REPEAT leaf ! DROP ; : LOOP -bal COMPILE (loop) rake, ; IMMEDIATE : +LOOP -bal COMPILE (+loop) rake, ; IMMEDIATE : UNDO COMPILE >undo ; IMMEDIATE \ Colon definitions : : \ create a word and enter the compiling loop. CURRENT @ CONTEXT ! header [ colon ] LITERAL nest, last @ @ CONTEXT @ ! 0 0 bal 2! ] ; : ; \ terminate a definition. bal 2@ OR ABORT" Unbalanced" last @ CURRENT @ ! COMPILE semi [COMPILE] [ ; IMMEDIATE \ Vocabularies : FORTH f CONTEXT ! ; : DEFINITIONS CONTEXT @ CURRENT ! ; \ new definitions will be into the CURRENT vocabulary. : VOCABULARY \ when executed, a vocabulary becomes first in the search order. VARIABLE HERE f CELL+ ( ie vlink) DUP @ , ! CELL GAP ( value for automatic initialization) DOES> @ ( ie >RAM) CONTEXT ! ; \ Misc. compiler support : IMMEDIATE last @ CELL+ DUP C@ BL ( ie 32) OR SWAP C! ; : [COMPILE] ' , ; IMMEDIATE \ force compilation of an otherwise immediate word. : ( [ASCII] ) parse 2DROP ; IMMEDIATE ( comments) : .( [ASCII] ) parse TYPE ; IMMEDIATE \ messages. : RECURSE last CELL+ @ , ; IMMEDIATE \ self-reference. ( Hall of fame-- high-level) EXIT : >< ( u - u2) { Control?} DUP 255 AND SWAP 256 * OR ; \ reverse the bytes within a cell. : WITHIN ( u n n2 - f) { CONTROLLED} OVER - >R - R> U< ; \ true if n <= u < n2 given circular comparison. ( Hall of fame-- low-level) CODE >< ( u - u2) { Control?} BL BH XCHG NEXT C; \ reverse the bytes within a word. : WITHIN ( u n n2 - f) { CONTROLLED} OVER - >R - R> U< ; \ true if n <= u < n2 given circular comparison. \ Byte move operators : CMOVE> ( a a2 u) { CONTROLLED} \ move u bytes from a to a2, rightmost byte first. DUP DUP >R D+ R> ?DUP IF 0 DO 1- SWAP 1- TUCK C@ OVER C! LOOP THEN 2DROP ; : MOVE ( a a2 u) \ move u bytes from a to a2 without overlap. >R 2DUP U< IF R> CMOVE> ELSE R> CMOVE THEN ; : ERASE ( a u) 0 FILL ; { CONTROLLED} : BLANK ( a u) BL FILL ; { CONTROLLED} ( Double-number math-- high-level) EXIT : S>D ( n - d) DUP 0< ; \ extend n to d. : D>S ( d - n) DROP ; \ truncate d to n. : D- ( d d2 - d') DNEGATE D+ ; { DOUBLE} : D2* ( d - d*2) 2DUP D+ ; { DOUBLE} : D2/ ( d - d/2) SWAP 2/ 32767 AND { DOUBLE} OVER 1 AND IF 32768 OR THEN SWAP 2/ ; { Require?} : M+ ( d n - d2) { DOUBLE} S>D D+ ; \ add n to d. ( Double-number math-- low-level) CODE S>D ( n - d) \ extend n to d. BX AX XCHG CWD AX PUSH BX DX XCHG NEXT C; CODE D>S ( d - n) BX POP NEXT C; \ truncate d to n. CODE D- ( d d2 - d3) BX DX MOV AX POP BX POP CX POP AX CX SUB CX PUSH DX BX SBB NEXT C; { DOUBLE} CODE D2* ( d - d2) { DOUBLE} AX POP AX SHL BX RCL AX PUSH NEXT C; CODE D2/ ( d - d2) { DOUBLE} AX POP BX SAR AX RCR AX PUSH NEXT C; CODE M+ ( d n - d2) { DOUBLE} \ add n to d. BX AX XCHG CWD BX POP CX POP AX CX ADD CX PUSH DX BX ADC NEXT C; \ More Double-number math : D< ( d d2 - f) ROT 2DUP = IF 2DROP U< EXIT THEN 2SWAP 2DROP > ; : D0= ( d - f) OR 0= ; { DOUBLE} : D= ( d d2 - f) D- OR 0= ; { DOUBLE} : DABS ( d - ud) DUP 0< IF DNEGATE THEN ; { DOUBLE} : DMAX ( d d2 - dmax) { DOUBLE} 2OVER 2OVER D< IF 2SWAP THEN 2DROP ; : DMIN ( d d2 - dmin) { DOUBLE} 2OVER 2OVER D< NOT IF 2SWAP THEN 2DROP ; \ Double-number operators : 2CONSTANT ( - w) CREATE , , DOES> 2@ ; \ create a double constant. { DOUBLE} : 2VARIABLE ( - a) VARIABLE 0 THERE ! CELL ALLOT ; \ create a double variable. { DOUBLE} : D@ ( a - d) 2@ ; { DOUBLE} : D! ( d a ) 2! ; { DOUBLE} : 2LITERAL ( w w2) ( - w w2) { DOUBLE} \ compile cell pair SWAP [COMPILE] LITERAL [COMPILE] LITERAL ; IMMEDIATE : D.R ( d n) { DOUBLE} \ print d right-justified in field of width n. >R TUCK DABS <# #S ROT SIGN #> R> OVER - 0 MAX SPACES TYPE ; ( Mixed-precision multiply and divide-- high-level) EXIT : M* ( n n2 - d) { DOUBLE} \ signed mixed-precision multiply. 2DUP XOR >R ABS SWAP ABS UM* R> 0< IF NEGATE THEN ; : M/MOD ( d n - rem quot) { CONTROLLED} \ signed rounded-down mixed-precision divide. 2DUP XOR >R OVER >R ABS >R DABS R> UM/MOD SWAP R> 0< IF NEGATE THEN SWAP R> 0< IF NEGATE THEN ; { Post-proposal to correct BASIS7 which makes M/MOD unsigned.} ( Mixed-precision multiply and divide-- low-level) CODE M* ( n n2 - d) { DOUBLE} \ signed mixed-precision multiply. BX AX XCHG DX POP DX IMUL AX PUSH DX BX MOV NEXT C; CODE M/MOD ( d n - rem quot) { CONTROLLED} DX POP AX POP \ signed rounded-down mixed-precision divide. BX BX OR 5 L# JZ ( divide by zero?) BX IDIV AX BX MOV DX PUSH NEXT 5 L: AX DX MOV 0 # BX MOV DX PUSH NEXT C; { Post-proposal to correct BASIS7 which makes M/MOD unsigned.} \ M*/ : M*/ ( d n +n2 - d2) { DOUBLE} \ (d * n)/+n2 rounded down with triple intermediate. >R 2DUP XOR R> 2>R ABS >R DABS R> 2>R R@ UM* 0 2R> UM* D+ ( multiply) R@ UM/MOD ROT ROT R> UM/MOD ROT ROT DROP ( divide) R> 0< IF DNEGATE THEN ; { Does +n2 excuse M*/ from having a floored equivalent?} \ Multiply and divide : /MOD ( n n2 - n3 n4) >R DUP 0< R> M/MOD ; : / ( n n2 - n3) /MOD NIP ; : MOD ( n n2 - n3) /MOD DROP ; \ Intermediate product is 32 bits: : */MOD ( n n2 n3 - n4 n5) >R M* R> M/MOD ; : */ ( n n2 n3 - n4) >R M* R> M/MOD NIP ; CODE * ( n n2 - n3) AX POP BX IMUL AX BX MOV NEXT C; : M/ ( d n - quot) { DOUBLE} M/MOD NIP ; \ signed rounded-down mixed-precision divide. EXIT : * ( n n2 - n3) UM* DROP ; \ Number conversion operator | : val? ( a u - d 2 , n 1 , 0) \ string to number conversion primitive. True if d is valid. \ Returns d if number ends in final '.' and sets dpl = 0 \ Returns n if no punctuation present and sets dpl = 0< [ #Jot 1- ] LITERAL MIN PAD 1- OVER - TUCK >R CMOVE BL PAD 1- DUP dpl ! C! 0 0 R> DUP C@ [ASCII] - = DUP >R - 1- BEGIN CONVERT DUP C@ DUP [ASCII] : = SWAP [ASCII] , [ASCII] / 1+ WITHIN OR WHILE DUP dpl ! REPEAT R> SWAP >R IF DNEGATE THEN PAD 1- dpl @ - 1- dpl ! R> PAD 1- = ( valid?) IF dpl @ 0< IF DROP 1 ELSE 2 THEN ELSE 2DROP 0 THEN ; : VAL? ( a u - d 2 , n 1 , 0) { Feature} 'val PERFORM ; \ Interpreter proper | : val, ( ... w) \ compiles the top w stack items as numeric literals. DUP BEGIN ROT >R 1- ?DUP 0= UNTIL BEGIN R> [COMPILE] LITERAL 1- ?DUP 0= UNTIL ; : interpret { Feature} \ the text compiler loop. BEGIN BL WORD FIND ?DUP IF STATE @ = ( Imm?) IF , ELSE EXECUTE THEN ELSE COUNT VAL? DUP huh? STATE @ IF [ 'val CELL+ ] LITERAL PERFORM ELSE DROP THEN THEN AGAIN ; \ QUIT support : EVALUATE ( a u) \ evaluate a string. #TIB 2@ 2>R #TIB 2! BLK 2@ 2>R 0 0 BLK 2! interpret 2R> BLK 2! 2R> #TIB 2! ; : EXPECT ( a +n) 'expect PERFORM ; : QUERY { CONTROLLED} \ fill TIB from next line of input stream. 0 0 BLK 2! TIB 80 EXPECT SPAN @ #TIB ! ; : ok? \ status check. D0 @ [ #Safe ] LITERAL - HERE U< ABORT" No Room" DEPTH 0< ABORT" Stack?" ; : OK? { Feature} ok? STATE @ 0= IF ." ok" THEN ; \ QUIT and ABORT : QUIT \ default main program. RESET BEGIN CR QUERY SPACE interpret OK? AGAIN ; : GRIPE ( a u) { Feature} \ default error handler. BLK @ IF BLK 2@ scr 2! THEN THERE COUNT TYPE SPACE ( msg ) TYPE ; : ABORT BEGIN PRESET QUIT GRIPE AGAIN ; \ default main program and error handler, courtesy Wil Baden. : ABORT" \ compile error handler and message. [COMPILE] IF [COMPILE] " COMPILE err [COMPILE] THEN ; IMMEDIATE ( Debug-- EXIT when done) : .S { RESERVED} \ display the data stack. DEPTH 0 MAX ?DUP CR IF 0 DO DEPTH I - 1- PICK . LOOP THEN ." <-Top " ; : DUMP ( a u) { RESERVED} \ simple dump. SPACE 0 DO DUP 7 AND 0= IF SPACE THEN DUP C@ . 1+ LOOP DROP ; : ? ( a) @ . ; { CONTROLLED} : WORDS { RESERVED} \ simple word list. CONTEXT @ BEGIN @ ?DUP WHILE DUP CELL+ COUNT 31 AND TYPE SPACE REPEAT ; \ GUARD and EMPTY : GUARD h H0 3 CELLS CMOVE THERE T0 ! ; { Feature} : EMPTY H0 h 3 CELLS CMOVE T0 @ r ! ; { Feature} \ ------ Device drivers --------------------------- HEX | CODE (type) ( a u) BX CX MOV DX POP 1 # BX MOV 40 # AH MOV 21 INT BX POP 'pause ) JMP C; | CODE KDOS ( - key -1 , ? 0) \ check for key pressed. \ Special keys are returned in high byte with low byte zeroed. BX PUSH FF # DL MOV 6 # AH MOV 21 INT 0 # BX MOV 2 L# JE AH AH SUB ( special key?) AL AL OR 1 L# JNZ 7 # AH MOV 21 INT AH AH SUB AL AH XCHG 1 L: TRUE # BX MOV 2 L: AX PUSH 'pause ) JMP C; DECIMAL \ KEY and EMIT actions 13 EQU #EOL ( end-of-line) 10 EQU #LF ( line-feed) HERE EQU $Eol #EOL C, #LF C, 2 EQU #Eol | : (cr) $Eol #Eol (type) ; | : (key?) ( - f) \ true if key pressed since last KEY. key' @ 0= IF KDOS key' 2! THEN key' @ ; : KEY ( - n) BEGIN (key?) UNTIL key' CELL+ @ 0 key' ! ; : EMIT ( b) hld C! hld 1 TYPE ; \ EXPECT action 08 EQU #BSP ( backspace) 127 EQU #DEL ( delete) 27 EQU #ESC ( escape) HERE EQU $Bsp ( * ) 3 C, #BSP C, BL C, #BSP C, | : expect ( a +n) >R 0 ( a o) \ read upto +n chars into address; stop at #EOL or #ESC BEGIN DUP R@ < WHILE KEY 127 ( 7-bit ASCII) AND DUP #BSP = OVER #DEL = OR IF DROP DUP IF 1- $Bsp COUNT TYPE THEN ELSE DUP #EOL = OVER #ESC = OR IF DROP SPAN ! R> 2DROP EXIT THEN ( otherwise) BL MAX >R 2DUP + R> OVER C! 1 TYPE 1+ THEN REPEAT SPAN ! R> 2DROP ; \ Dumb terminal actions | : (keys) ( a +n) >R 0 ( a o) \ read upto +n chars into address without echo; stop at #EOL BEGIN DUP R@ < WHILE KEY DUP #EOL = IF R> 2DROP DUP >R ( early out) ELSE BL MAX >R 2DUP + R> SWAP C! 1+ THEN REPEAT SPAN ! R> 2DROP ; | : (mark) ( a n) ." ^" TYPE ; | : (page) 25 0 DO CR LOOP ; | : (tab) ( n n2) CR DROP SPACES ; \ Initialize automatic variables HERE EQU RAMs ] nope expect source nope nope val? val, [ ( key' ) 0 , 0 , HERE RAMs - EQU #RAMs \ ------ Initialization --------------------------- D0 CONSTANT parms \ System parameter table. CREATE glass \ Simple transfer table. ] (type) (cr) (keys) (key?) (mark) (page) (tab) nope [ : READY ." Ready" ; { Feature} \ Initialize application. : BYE 0 EXECUTE ; { Feature} \ Shut down application. \ Initialization-- high-level 170 CONSTANT VERSION { Feature} \ ZEN 1.70 | : vocabs \ initialize vocabularies. f CELL+ ( ie vlink) BEGIN @ ?DUP WHILE DUP CELL+ @ OVER CELL - @ ( ie >RAM) ! REPEAT ; | : cold \ high-level coldstart initialization. TRUE ( wake) entry entry 2! T0 2@ r 2! glass x ! RAMs 'pause #RAMs CMOVE EMPTY vocabs PRESET FORTH DEFINITIONS DECIMAL " READY" EVALUATE ABORT ; \ If all definitions are headerless, substitute: READY ABORT ; \ Initialization-- low-level HEX HERE ( *) ," No Room $" | CODE Coldstart \ low-level initialization. 1000 # BX MOV 4A # AH MOV 21 INT ( enough room?) 1 L# JNC ( No:) ( *) 1+ # DX MOV 9 # AH MOV 21 INT 0 # JMP ( Bye) 1 L: #SP0 # SP MOV #RP0 # BP MOV BP u ) MOV ' cold >BODY # SI MOV ( I register) NEXT C; DECIMAL HERE ( * ) Power ORG ASSEMBLER ' Coldstart # JMP C; ( * ) ORG \ ------ FILE extension --------------------------- #Used USER IO-RESULT DROP 26 EQU #EOF \ control-Z marks the end of older text files. 128 EQU buff \ MS-DOS command tail and default fcb buffer. 200 EQU name \ RENAME-FILE takes two names. 255 name - EQU #name \ size of name in bytes plus zero. | : >fname ( a u - a2) \ convert string to ASCIIZ file name. #name MIN name 2DUP 2>R SWAP MOVE R@ 0 2R> + C! ; \ MS-DOS interface HEX CODE fdos ( DX CX handle function# - AX) \ generic call to MS-DOS BX AX MOV BX POP CX POP DX POP 21 INT LABEL return AX BX MOV 1 L# JB AX AX SUB 2 L# JZ 1 L: BX BX SUB ( non-zero retcode forces zero result) 2 L: u ) DI MOV AX IO-RESULT entry - [DI] MOV NEXT C; | CODE rename ( a a2 function# - AX) BX AX MOV DI POP DX POP 21 INT return JU C; | CODE seek ( DX CX handle function# - AX DX) BX AX MOV BX POP CX POP DX POP 21 INT DX PUSH return JU C; DECIMAL \ 5 file primitives HEX : OPEN-FILE ( a u - w) >fname 0 0 3D02 fdos ; : CREATE-FILE ( a u - w) >fname 0 0 3C00 fdos ; : DELETE-FILE ( a u) >fname 0 0 4100 fdos DROP ; : CLOSE-FILE ( w) DUP DUP 3E00 fdos DROP ; : RENAME-FILE ( a u a2 u2) >fname buff #name CMOVE> >fname buff 5600 rename DROP ; DECIMAL \ Read, write and seek bytes HEX \ Read or write u bytes to or from address a to file w. : READ-FILE ( a u w - u2) 3F00 fdos ; : WRITE-FILE ( a u w - u2) 4000 fdos ; : SEEK-FILE ( doff n w - dpos) \ add an offset to file w. \ n neg: to start; n pos: to end; n zero: to current. SWAP DUP IF 0< CELLS 1+ THEN 4201 + seek ; \ Return file position or size. : FILEPOS ( w - d) >R 0 0 0 R> SEEK-FILE ; : FILESIZE ( w - d) >R 0 0 1 R> SEEK-FILE ; DECIMAL \ Read and write lines of text : WRITE-CR ( w) $Eol #Eol ROT WRITE-FILE DROP ; \ write end-of-line sequence to file. : READ-LINE ( a u w - 0 0 | u2 t) \ read line from file into buffer. \ u2 bytes are actually read. False on end-of-file. >R 2DUP 1+ R@ READ-FILE ( a u u2) DUP 0= IF R> 2DROP 2DROP 0 0 EXIT THEN ( end of file) >R OVER R> TUCK #EOL SCAN NIP ( a u u2 u3) ?DUP IF #Eol OVER - >R - ELSE 2DUP U< >R THEN MIN R> ( a u4 #seek) ?DUP IF S>D 0 R@ SEEK-FILE 2DROP THEN TUCK #EOF SCAN NIP - ( just NIP if no control-Zs) R> DROP TRUE ; \ Load and save files : \ #TIB @ >IN ! ; IMMEDIATE \ treat the rest of the line as a comment, like this one. RAMs CONSTANT RAMs \ make headers for SAVING in the #RAMs CONSTANT #RAMs \ KERNEL.SRC file. : GO ( a u) { Feature} \ evaluate the KERNEL.SRC file. " KERNEL.SRC" OPEN-FILE DUP huh? ( w) >R BEGIN buff DUP 64 R@ READ-LINE WHILE EVALUATE REPEAT 2DROP R> CLOSE-FILE ;
